home *** CD-ROM | disk | FTP | other *** search
/ SPACE 1 / SPACE - Library 1 - Volume 1.iso / program / 16 / blockld.fth < prev    next >
Text File  |  1985-11-19  |  2KB  |  62 lines
  1. \ More stuff for standard Forth BLOCKs
  2.  
  3. forth definitions
  4. nuser block-file
  5. nuser block-input-file
  6.  
  7. : !files  (s fcb -- )   dup block-file !  block-input-file !  ;
  8. \ : default (s -- )   [ sys ] open-default-file !files  ;
  9.  
  10. : file?   (s -- )   block-file @ .file  ;
  11. : switch  (s -- )
  12.    block-file @ block-input-file @ block-file ! block-input-file !  ;
  13. : capacity   (s -- n )
  14.   [ sys ] block-file @  file#blocks ;
  15.  
  16. : buffer   (s n -- a )   block-file @ (buffer)  ;
  17. : block    (s n -- a )   block-file @ (block)  ;
  18. : flush    (s -- )
  19.    save-buffers  0 block drop  empty-buffers  ;
  20. : in-block  (s n -- a )   block-input-file @ (block)  ;
  21. : view#    (s -- addr )    block-file @ 40 +   ;
  22.  
  23. : use-file ( str -- )
  24.   [ sys ] open-file !files
  25. ;
  26. : using  \ filename  ( -- )
  27.   bl word  use-file
  28. ;
  29. \ block-load  interprets Forth source code from a block buffer.
  30. \ This works by copying the block into the file buffer, and assumes
  31. \ that the file buffer is at least as big as a block.
  32.  
  33. : block-fwrite ( addr count l.byteno fd -- count )  \ Does nothing
  34.   drop ldrop nip
  35. ;
  36. : block-flen ( fd -- size ) drop b/buf ;
  37. : load ( block# -- )
  38.   get-fd
  39.   block  bfbase @  b/buf  cmove         ( )
  40.   bfbase @  b/buf  +                    ( end )
  41.   dup bflimit !  dup bfend !  bftop !
  42.  
  43.   0                 fid    !
  44.   modify            fmode  !
  45.   ['] nullread      fread  !
  46.   ['] block-fwrite  fwrite !
  47.   ['] drop          fclose !
  48.   ['] noop          falign !
  49.   ['] block-flen    flen   !
  50.  
  51.   file @ dup >r (load r> close
  52. ;
  53.  
  54. \ Backslash (comment to end of line) for blocks:
  55. \ hex
  56. \ : \  \ rest-of-line  ( -- )
  57. \    in-file @ file !
  58. \    bfcurrent @  bfbase @  -   63 +   63 not  and 
  59. \    bfcurrent !
  60. \ ;
  61.   loop  ?dup
  62.    if  buffer# dup >buffers /bufhdr cm